home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Franz PD / Franz PD Disk #324 (1994-04)(Rhein-Sieg-Soft).zip / Franz PD Disk #324 (1994-04)(Rhein-Sieg-Soft).adf / VideoText3.5 / source / datei.p < prev    next >
Text File  |  1994-04-01  |  6KB  |  175 lines
  1. UNIT Datei; {$project vt}
  2. { Dateioperationen zum Programm VideoText }
  3.  
  4. INTERFACE; FROM vt USES global,decode,sys;
  5.  
  6. FUNCTION filetype(name: Str80): Integer;
  7. FUNCTION savepage(seite: p_onepage, name: str80): Boolean;
  8. FUNCTION savebox(seite: p_onepage; name: str80; farbig: Boolean): Boolean;
  9.  
  10. { ---------------------------------------------------------------------- }
  11.  
  12. IMPLEMENTATION;
  13. {$ opt b- }
  14.  
  15. FUNCTION filetype{(name: Str80): Integer};
  16. { Typcodierung: }
  17. { -1: Datei existiert nicht }
  18. {  0: unbekannter Typ (vermutlich roher ASCII-Text) }
  19. {  1: programmeigener Typ 'VTPG'=$56545047 }
  20. {  2: AmigaDOS-Programmdatei $000003F3 }
  21. {  3: IFF-Datei 'FORM'=$464F524D }
  22. VAR head: Long;
  23.     i: Integer;
  24.     ch: Char;
  25.     datei: Text;
  26. BEGIN
  27.   Reset(datei,name);
  28.   IF IOresult=0 THEN BEGIN
  29.     head := 0;
  30.     FOR i := 1 TO 4 DO BEGIN
  31.       Read(datei,ch);
  32.       head := head SHL 8 + Ord(ch);
  33.     END;
  34.     filetype := 0;
  35.     IF head=$56545047 THEN filetype := 1;
  36.     IF head=$000003F3 THEN filetype := 2;
  37.     IF head=$464F524D THEN filetype := 3;
  38.     Close(datei);
  39.   END ELSE
  40.     filetype := -1;
  41. END;
  42.  
  43. FUNCTION savepage{(seite: p_onepage, name: str80): Boolean};
  44. { Seite abspeichern, drei Formate möglich: ASCII, rohe Daten, IFF-Bild }
  45. VAR i, spalte, zeile, x0, y0, delta: Integer;
  46.     j, k, bunt, packbar: Integer;
  47.     l: Long;
  48.     s: str80;
  49.     bytes: ^ARRAY [1..41] OF Char;
  50.     datei: Text;
  51. PROCEDURE putshort(w: Word);
  52.   BEGIN Write(datei,chr(Hi(w)),chr(Lo(w))); END;
  53. PROCEDURE putlong(l: Long);
  54.   BEGIN putshort(Word(l SHR 16)); putshort(Word(l AND $FFFF)); END;
  55. BEGIN
  56.   savepage := false;
  57.   IF overwrite OR (AsciiRawIff=3) THEN
  58.     rewrite(datei,name)
  59.   ELSE BEGIN
  60.     Reset(datei,name);
  61.     IF (IOresult<>0) THEN { Datei existiert vermutlich nicht }
  62.       Rewrite(datei,name);
  63.   END;
  64.   IF IOresult<>0 THEN     { wahrscheinlich 'Object in use' }
  65.     Exit;
  66.   Seek(datei,FileSize(datei));
  67.   CASE AsciiRawIff OF
  68.     1: for zeile := 0 to 23 do begin   { ASCII-Textausgabe }
  69.         makeascii(seite, zeile, true, s);
  70.         writeln(datei,s);
  71.       end;
  72.     2: begin  { (beinahe) rohes VT-Format }
  73.       WriteLn(datei,'VTPG');
  74.       FOR zeile := 0 to 23 DO BEGIN
  75.         bytes := Ptr(^seite^.chars[40*zeile]);
  76.         BlockWrite(datei,bytes^,40);
  77.         WriteLn(datei);
  78.       END;
  79.       Write(datei,seite^.pg,' ',seite^.sp,' $');
  80.       { Steuerbits hexadezimal ausgeben: }
  81.       FOR i := 3 DOWNTO 0 DO BEGIN
  82.         j := (seite^.cbits SHR (4*i)) AND $F;
  83.         IF j<10 THEN Write(datei,chr(j+ord('0')))
  84.           ELSE Write(datei,chr(j-10+ord('A')));
  85.       END;
  86.       WriteLn(datei);
  87.     end;
  88.     3: BEGIN  { IFF-Grafik speichern, als LoRes, 320x256, 3 Bitplanes }
  89.       write(datei,'FORM'); putlong(24080);  { wird später korrigiert }
  90.       write(datei,'ILBM');
  91.       write(datei,'BMHD'); putlong(20);
  92.       putshort(320); putshort(216); { Breite, Höhe der Bitmap }
  93.       putshort(0); putshort(0); { x/y-Offset }
  94.       write(datei,chr(3)); { 3 Bitplanes }
  95.       write(datei,chr(0)); { keine Maske }
  96.       write(datei,chr(1)); { Grafikdaten mit Byte-Running gepackt !!! }
  97.       write(datei,chr(0)); { Füllbyte }
  98.       putshort(0); { transparente Farbe }
  99.       write(datei, chr(10), chr(11));  { x/y-Verhältnis ~1:1 }
  100.       putshort(320); putshort(256); { Breite, Höhe des Bildschirms }
  101.       write(datei,'CMAP'); putlong(24);
  102.       for i := 0 to 7 do
  103.         write(datei,chr($F0*(i AND 1)),chr($78*(i AND 2)),chr($3C*(i AND 4)));
  104.       write(datei,'CAMG'); putlong(4);
  105.       putlong(0);  { ViewMode: weder HIRES noch LACE! }
  106.       write(datei,'BODY'); putlong(24000);    { Wert wird später korrigiert }
  107.       for zeile := 0 to 215 do begin
  108.         for i := 0 to 2 do begin
  109.           bytes := Ptr(Long(bitmapzeile(i,zeile))+39);
  110.           { Zeile von bytes[] nach s[] packen (Byte-Running): }
  111.           j := 1; k := 0;
  112.           bunt := 0;
  113.           repeat
  114.             packbar := 1;
  115.             while (bytes^[j+packbar]=bytes^[j+packbar-1]) AND (j+packbar<40) do
  116.               Inc(packbar);
  117.             if packbar>2 then begin { lohnt packen? }
  118.               Inc(k); s[k] := chr(257-packbar); Inc(k); s[k] := bytes^[j];
  119.               j := j + packbar; bunt := 0;
  120.             end else begin
  121.               Inc(bunt); if bunt=1 then Inc(k);
  122.               Inc(k); s[k] := bytes^[j]; s[k-bunt] := chr(bunt-1);
  123.               Inc(j);
  124.             end;
  125.           until j > 40;
  126.           BlockWrite(datei,s,k);
  127.         end;
  128.       end;
  129.       { Chunk-Größen korrigieren }
  130.       l := filesize(datei);
  131.       if Odd(l) then begin write(datei,chr(0)); Inc(l); end;
  132.       seek(datei,4); putlong(l-8);
  133.       seek(datei,88); putlong(l-92);
  134.     END;
  135.   END;
  136.   Close(datei);
  137.   savepage := True;
  138. END;
  139.  
  140. FUNCTION savebox{(seite: p_onepage; name: str80; farbig: Boolean): Boolean};
  141. { Gibt eine auf der Seite befindliche Box in eine Textdatei aus. Wenn die }
  142. { Seite keine Box enthält, nur eine Leerzeile. }
  143. { <farbig> entscheidet, ob Farbsteuerzeichen als Klartext ausgegeben oder }
  144. { einfach unterdrückt werden. }
  145. VAR zeile,i: Integer;
  146.     s: str80;
  147.     datei: Text;
  148.     boxline: Boolean;
  149. BEGIN
  150.   savebox := False;
  151.   Reset(datei,name);
  152.   IF (IOresult<>0) THEN   { Datei existiert vermutlich nicht }
  153.     Rewrite(datei,name);
  154.   IF IOresult<>0 THEN     { wahrscheinlich 'Object in use' }
  155.     Exit;
  156.   Seek(datei,FileSize(datei));
  157.   FOR zeile := 0 to 23 DO BEGIN
  158.     boxline := False;
  159.     if seite<>Nil then for i := 0 to 39 do
  160.       if (seite^.chars[zeile*40+i]=11) THEN
  161.         boxline := True;
  162.     IF boxline THEN BEGIN
  163.       makeascii(seite, zeile, NOT farbig, s)
  164.       WriteLn(datei, s);
  165.     END;
  166.   END;
  167.   WriteLn(datei);
  168.   Close(datei);
  169.   savebox := True;
  170. END;
  171.  
  172. BEGIN  { Initialisierungen }
  173. END.
  174.  
  175.